home *** CD-ROM | disk | FTP | other *** search
/ Dr. Windows 3 / dr win3.zip / dr win3 / WINPROGS / DLGDSN41.ZIP / PASSRC2.PAS < prev    next >
Pascal/Delphi Source File  |  1993-12-20  |  18KB  |  703 lines
  1. {Substitutions and fills in file, skel.dat
  2.   Area Fills
  3.   @ZZ0    Form the dialog in constructor
  4.   @ZZ1    Defined Control Names in Object Def.
  5.   @ZZ2    Data record def
  6.   @ZZ3    Load GetSubViewPtr
  7.   @ZZ4    Store PutSubViewPtr
  8.  
  9.   Substitutions
  10.   @XX0    Dialog's Pointer  (as  PMyDialog)
  11.   @XX1    Dialog's Symbol   (as  TMyDialog)
  12.   @XX2    Dialog's ancestor (usually TDialog)
  13.   @XX3    Dialog's registration TStreamRec (as RMyDialog)
  14.   @XX4    Unit name
  15.   @XX5    'Control1'
  16.   @XX6    uses clause items
  17.  
  18. }
  19. {$A-,B-,E+,F-,G-,I+,N-,O-,P-,Q-,R-,S-,T-,V-,X+}
  20. {$M 16384,5000,655360}
  21.  
  22. Program PasSrc2;
  23.  
  24. uses Dos, Objects, Drivers, Views, Dialogs,
  25.      Editors, Validate, ReadScpt;
  26.  
  27. const
  28.   NeedControl1 : boolean = False;
  29. var
  30.   OutF : Text;
  31.   S : String;
  32.  
  33. PROCEDURE Subst(I : Integer);   {make a substitution for @XXn.  I is the
  34.   location of @XXn in S }
  35. var
  36.   N : Byte;
  37.   St : String;
  38.   Name : NameStr;
  39.   Ext : ExtStr;
  40. begin
  41. N := Ord(S[I+3]) - Ord('0');  {get the substitution number}
  42. Delete(S, I, 4);              {delete the @XXn }
  43. case N of
  44.   0 : Insert(Dialog^.MainBlock.Obj^, S, I);  {like PMyDialog}
  45.   1 : begin
  46.       St := Dialog^.MainBlock.Obj^;
  47.       if St[1] in ['P', 'p'] then Delete(St,1,1);
  48.       Insert('T', St, 1);
  49.       Insert(St, S, I);
  50.       end;
  51.   2 : Insert(Dialog^.MainBlock.BaseObj^, S, I);  {like TDialog}
  52.   3 : begin
  53.       St := Dialog^.MainBlock.Obj^;
  54.       if St[1] in ['P', 'p'] then Delete(St,1,1);
  55.       Insert('R', St, 1);
  56.       Insert(St, S, I);
  57.       end;
  58.   4 : begin   {unit name same as filename}
  59.       FSplit(ParamStr(2), St, Name, Ext);
  60.       Insert(Name, S, I);
  61.       end;
  62.   5 : if NeedControl1 then Insert(', Control1', S, I);
  63.   6 : begin
  64.       St := '';
  65.       if Present[CText] then St := ', ColorTxt';
  66.       if Present[ILong] then St := St+', InpLong';
  67.       if Present[Memo] then St := St+', Editors';
  68.       if ValidatorPresent then St := St+', Validate';
  69.       if St <> '' then Insert(St, S, I);
  70.       end;
  71.   end;
  72. end;
  73.  
  74. function Positn(Pat, Src : String; I : Integer) : Integer;
  75. {find the position of a substring in a string starting at the Ith char}
  76. var
  77.   N : Integer;
  78. begin
  79. if I < 1 then I := 1;
  80. Delete(Src, 1, I-1);
  81. N := Pos(Pat, Src);
  82. if N = 0 then Positn := 0
  83.   else Positn := N+I-1;
  84. end;
  85.  
  86. FUNCTION Quoted(S : string) : string;
  87. {If first char is '@' then removes the '@' and otherwise does nothing--
  88.    assumes string is a variable name.
  89.  else
  90.    Puts single quotes around a string and doubles any internal single quotes}
  91. var
  92.   I : Integer;
  93. begin
  94. I := Pos('@', S);
  95. if I = 1 then
  96.   begin
  97.   Quoted := Copy(S, 2, 255);
  98.   Exit;
  99.   end;
  100. I := Pos('''', S);
  101. while I > 0 do
  102.   begin
  103.   Insert('''', S, I);
  104.   I := Positn('''', S, I+2);
  105.   end;
  106. Insert('''', S, 1);
  107. Quoted := S+'''';
  108. end;
  109.  
  110. procedure RDotAssign(P : PScriptRec);
  111. begin
  112. with P^.MainBlock do
  113.   begin
  114.   WriteLn(Outf, 'R.Assign(', X1, ', ', Y1, ', ', X2,', ', Y2, ');');
  115.   end;
  116. end;
  117.  
  118. procedure DoOpEvent(P : PScriptRec; const Sym : string);
  119. var
  120.   S : string;
  121. begin
  122. with P^.MainBlock do
  123.   begin
  124.   if DefOptns <> Optns then
  125.     begin
  126.     Write(Outf, Sym, '^.Options := ');
  127.     S := OptionStr(Optns, DefOptns, GetOptionWords);
  128.     if S[1] = '$' then
  129.       WriteLn(OutF, S)
  130.     else WriteLn(OutF, Sym, '^.Options', S);
  131.     end;
  132.   if DefEvMsk <> EvMsk then
  133.     begin
  134.     Write(Outf, Sym, '^.EventMask := ');
  135.     S := OptionStr(EvMsk, DefEvMsk, GetEventWords);
  136.     if S[1] = '$' then
  137.       WriteLn(OutF, S)
  138.     else WriteLn(OutF, Sym, '^.EventMask', S);
  139.     end;
  140.   end;
  141. end;
  142.  
  143. (*--
  144. procedure DoOpEvent(P : PScriptRec; const Sym : string);
  145. begin
  146. with P^.MainBlock do
  147.   begin
  148.   if DefOptns <> Optns then
  149.     WriteLn(Outf, Sym, '^.Options := ', Sym, '^.Options',
  150.                   OptionStr(Optns, DefOptns, GetOptionWords));
  151.   if DefEvMsk <> EvMsk then
  152.     WriteLn(Outf, Sym, '^.EventMask := ', Sym, '^.EventMask',
  153.                   OptionStr(EvMsk, DefEvMsk, GetEventWords));
  154.   end;
  155. end;   ---*)
  156.  
  157. PROCEDURE WriteHelpCtx(Rf : PString; H : String; Ctx : word);
  158. Const
  159.   NoContext : String[11] = 'hcNoContext';
  160. begin
  161. if (H = '') and (Ctx > 0) then
  162.    Str(Ctx, H);
  163. if (H <> '') and not SameString(H, NoContext) then
  164.   if Rf <> Nil then
  165.     WriteLn(OutF, Rf^, '^.HelpCtx := ', H, ';' )
  166.   else WriteLn(OutF, 'HelpCtx := ', H, ';' )
  167. end;
  168.  
  169. procedure WriteButton(P : PScriptRec);
  170. var
  171.   S : string[55];
  172.  
  173.   function FlagStr : string;
  174.   var
  175.     S : string[55];
  176.   begin
  177.   with P^ do
  178.     begin
  179.     S := '';
  180.     if Flags = 0 then S := 'bfNormal'
  181.     else
  182.       begin
  183.       if Flags and 1 <> 0 then S := 'bfDefault+';
  184.       if Flags and 2 <> 0 then S := S+'bfLeftJust+';
  185.       if Flags and 4 <> 0 then S := S+'bfBroadcast+';
  186.       if Flags and 8 <> 0 then S := S+'bfGrabFocus+';
  187.       Dec(S[0]);  {remove extra '+'}
  188.       end;
  189.     end;
  190.   FlagStr := S;
  191.   end;
  192.  
  193. begin
  194. with P^, MainBlock do
  195.   begin
  196.   RDotAssign(P);
  197.   if SameString(Obj^, 'POptionButton') then  {a special TOptionButton}
  198.     WriteLn(OutF, VarName^, ' := New(', Obj^, ', Init(R, ', Param[1]^,
  199.          ', '+Param[2]^+'));' )
  200.   else
  201.     begin   {regular button}
  202.     if CommandName^ <> '' then S := CommandName^
  203.       else Str(CommandValue, S);
  204.     Write(OutF, VarName^, ' := New(', Obj^, ', Init(R, ',
  205.          Quoted(ButtonText^), ', '+S+', ' );
  206.     WriteLn(OutF, FlagStr+'));' );
  207.     end;
  208.   WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
  209.   DoOpEvent(P, VarName^);
  210.   WriteLn(OutF, 'Insert(', VarName^, ');');
  211.   end;
  212. end;
  213.  
  214. procedure WriteInputLong(P : PScriptRec);
  215. begin
  216. with P^, MainBlock do
  217.   begin
  218.   RDotAssign(P);
  219.   WriteLn(OutF,
  220.          VarName^, ' := New('+Obj^+', Init(R, ', LongStrLeng,
  221.          ', ', LLim, ', ', ULim,  ', ', ILOptions, '));' );
  222.   WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
  223.   DoOpEvent(P, VarName^);
  224.   WriteLn(OutF, 'Insert(', VarName^, ');');
  225.   end;
  226. end;
  227.  
  228. procedure WriteInputLine(P : PScriptRec);
  229. var
  230.   S : string[15];
  231.  
  232.   function DoubleInsideQuotes(St : string) : string;
  233.   var
  234.     I : integer;
  235.   begin
  236.   I := Pos('''', St);
  237.   while I > 0 do
  238.     begin
  239.     Insert('''', St, I);
  240.     I := Positn('''', St, I+2);
  241.     end;
  242.   DoubleInsideQuotes := St;
  243.   end;
  244.  
  245. begin
  246. with P^, MainBlock do
  247.   begin
  248.   RDotAssign(P);
  249.   WriteLn(OutF,
  250.          VarName^, ' := New('+Obj^+', Init(R, ', StringLeng, '));' );
  251.   WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
  252.   DoOpEvent(P, VarName^);
  253.   WriteLn(OutF, 'Insert(', VarName^, ');');
  254.  
  255.   if ValKind in [Picture..StringLookup] then
  256.     begin
  257.     Write(OutF, '  ', Obj^+'('+VarName^+')^.Validator := New(', ValPtrName^,
  258.         ', Init(');
  259.     case ValKind of
  260.       Picture:
  261.          begin
  262.          if AutoFill <> 0 then S := 'True' else S := 'False';
  263.          {Note: PictureString may start with '@'}
  264.          WriteLn(OutF, '''', DoubleInsideQuotes(PictureString^), ''', ', S, '));');
  265.          end;
  266.       Range:
  267.          begin
  268.          WriteLn(OutF, LowLim, ', ', UpLim, '));');
  269.          if Transfer <> 0 then
  270.            WriteLn(OutF, '  ',
  271.                Obj^+'('+VarName^+')^.Validator^.Options := voTransfer;');
  272.          end;
  273.       Filter:
  274.          WriteLn(OutF, CharSet^, '));');
  275.       StringLookup:
  276.          WriteLn(OutF, List^, '));');
  277.       end;
  278.     end;
  279.   end;
  280. end;
  281.  
  282. procedure WriteMemo(P : PScriptRec);
  283. begin
  284. with P^, MainBlock do
  285.   begin
  286.   RDotAssign(P);
  287.   Write(OutF,
  288.          VarName^, ' := New('+Obj^+', Init(R, ');
  289.   if HScroll^ <> '' then
  290.     Write(OutF, 'PScrollbar(Control1), ')
  291.   else Write(OutF, 'Nil, ' );
  292.   if VScroll^ <> '' then
  293.     Write(OutF, 'PScrollbar(Control), ')
  294.   else Write(OutF, 'Nil, ' );
  295.   WriteLn(OutF, 'Nil, ', BufSize, '));');
  296.   WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
  297.   DoOpEvent(P, VarName^);
  298.   WriteLn(OutF, 'Insert(', VarName^, ');');
  299.   end;
  300. end;
  301.  
  302. procedure WriteListBox(P : PScriptRec);
  303. begin
  304. with P^, MainBlock do
  305.   begin
  306.   RDotAssign(P);
  307.   Write(OutF,
  308.          VarName^, ' := New('+Obj^+', Init(R, ', Columns);
  309.   if Scrollbar^ <> '' then
  310.     WriteLn(OutF, ', PScrollbar('+ScrollBar^+')));')
  311.   else WriteLn(OutF, ', Nil));' );
  312.   WriteHelpCtx(VarName, HelpCtxSym^,